home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d21 / apishare.arc / SHAREB.PAS < prev   
Pascal/Delphi Source File  |  1988-10-22  |  3KB  |  147 lines
  1. (****************************************************************
  2. *
  3. *  Name:          SHAREB
  4. *
  5. *  Function:      share memory/data with another process
  6. *
  7. *  Shows how to:  1. read from and write to shared memory.
  8. *                 2. receive from another process the address of shared data.
  9. *                 3. control access to shared data via mailbox semaphore.
  10. *
  11. ****************************************************************)
  12.  
  13. program ShareB;
  14.  
  15. uses DVAPI;
  16.  
  17. const
  18.  
  19.   (* minimum API version required *)
  20.   REQUIRED = $201;
  21.  
  22. var
  23.  
  24.   (* API version number *)
  25.   version : integer;
  26.  
  27.   (* TFDD text file *)
  28.   tfd : text;
  29.  
  30.   (* application handle of other process *)
  31.   apphana : ULONG;
  32.  
  33.   (* mail-related variables *)
  34.   status : integer;
  35.   malptr : pointer;
  36.   mallng : integer;
  37.  
  38. type
  39.  
  40.   (* type declarations related to shared data *)
  41.   DATATYPE = string;
  42.   DATAPTR = ^DATATYPE;
  43.  
  44. const
  45.  
  46.   (* constant value to be assigned to shared memory *)
  47.   SHRCONST : DATATYPE = '     BBBBB';
  48.  
  49. var
  50.  
  51.   (* pointer to pointer to shared data *)
  52.   shrptrptr : ^DATAPTR;
  53.  
  54.   (* pointer to shared data *)
  55.   shrptr : DATAPTR;
  56.  
  57.   (* mailbox semaphore controlling access to shared memory *)
  58.   sema : ULONG;
  59.  
  60. const
  61.  
  62.   (* global name of mailbox *)
  63.   name : string = 'Shared Memory Semaphore';
  64.  
  65.  
  66. procedure program_body;
  67. begin
  68.  
  69.   (* open TFDD *)
  70.   tfd_open (tfd,win_me);
  71.  
  72.   (* find named mailbox semaphore *)
  73.   sema := mal_sfind (name);
  74.  
  75.   (* read pointer to mailed data *)
  76.   status := mal_read (mal_me,malptr,mallng);
  77.  
  78.   (* assign read pointer to a variable which is a pointer to a pointer *)
  79.   shrptrptr := malptr;
  80.  
  81.   (* assign pointer to shared data by dereferencing pointer to pointer *)
  82.   shrptr := shrptrptr^;
  83.  
  84.   (* get the application task handle of other process *)
  85.   apphana := mal_addr (mal_me);
  86.  
  87.   (* begin critical region *)
  88.   api_beginc;
  89.  
  90.   (* loop till handle of other process is no longer valid *)
  91.   while (api_isobj (apphana)) do
  92.   begin
  93.  
  94.     (* lock semaphore *)
  95.     mal_lock (sema);
  96.  
  97.     (* read & display current contents & address of shared data *)
  98.     writeln (tfd,shrptr^,' at ',seg (shrptr^),':',ofs (shrptr^));
  99.  
  100.     (* modify contents of shared data *)
  101.     shrptr^ := SHRCONST;
  102.  
  103.     (* unlock semaphore *)
  104.     mal_unlock (sema);
  105.  
  106.     (* end critical region *)
  107.     api_endc;
  108.  
  109.     (* begin critical region *)
  110.     api_beginc;
  111.  
  112.   end;
  113.  
  114.   (* close TFDD *)
  115.   tfd_close (tfd);
  116.  
  117. end;
  118.  
  119.  
  120. (**********************************************************************
  121. *  main  -  check for DESQview present and enable required extensions.
  122. ***********************************************************************)
  123.  
  124. begin
  125.  
  126.   (* initialize Pascal interfaces and get API version number *)
  127.   version := api_init;
  128.  
  129.   (* if DESQview is not running or version is too low, display a message *)
  130.   if (version < REQUIRED) then
  131.     writeln ('This program requires DESQview version ',REQUIRED div 256,
  132.        '.',(REQUIRED mod 256) div 16,(REQUIRED mod 256) mod 16,' or later.')
  133.  
  134.   else
  135.   begin
  136.  
  137.     (* tell DESQview what extensions to enable and start application *)
  138.     api_level (REQUIRED);
  139.     program_body;
  140.  
  141.     (* disable Pascal interfaces and return from program *)
  142.     api_exit;
  143.  
  144.   end;
  145.  
  146. end.
  147.